home *** CD-ROM | disk | FTP | other *** search
/ BMUG PD-ROM A / PD-ROM A.iso / Programming / Programming Languages / Pocket Forth rel.5 / Source code / applSource / aInterp.txt next >
Encoding:
Text File  |  1991-06-23  |  3.9 KB  |  135 lines  |  [TEXT/EDIT]
  1. ; aInterp.txt 8:12:05 AM  2/11/87
  2. ; add Held 2:45:49 PM  5/31/87
  3. ; v 0.3 DA compatable 11:47:16 AM  1/21/88
  4. ; Mon Apr 25, 1988 15:12:04 macros
  5. ; Wed Apr 27, 1988 12:30:48 v 0.4
  6. ; Mon Jun 03, 1991 23:40:00 restructure
  7.  
  8.  
  9. TermBuf        DCB.B    84,32        ; command line buffer
  10. IntA7:        DC.L    0        ; initial value for A7
  11. Rzero:        DC.L    0        ; value for A7 after linking
  12. UFlow:        DC.L    0        ; room for stack underflow
  13. Szero:        DC.L    0        ; bottom of stack
  14. Expand:        DC.L    0        ; hold address of expand routine
  15. FreePt:        DC.W    dictend-Base    ; initial compile point freespace
  16. FreeSz:        DC.W    4096        ; initial headroom
  17. DictPt:        DC.W    task-theLink    ; initial dict. search start
  18. NBase:        DC.W    10        ; the numeric radix
  19. Held:        DC.W    0        ; the HLD data
  20. DoesAddr:    DC.L    0        ; "does>" jump address
  21. fcolon:        DC.B    0        ;   compile mode
  22. fimmed:        DC.B    0        ;   immediate flag
  23. fneg:        DC.B    0        ;   negative flag
  24. fint:        DC.B    $80        ;   interactive mode
  25. fmacro:        DC.W    0        ;   macro flag+filler
  26.  
  27. Cold:    ; Set the Base pointer
  28.     LEA    Bottom,BP
  29.     MOVE.L    A1,Expand-Base(BP)    ; a present from the application
  30.  
  31.     ; setup the interface
  32.     JSR    MacStart-base(BP)    ; moved 6/3/91
  33.  
  34.     ; setup the stacks
  35.     LEA    IntA7-Base(BP),A0    ; A7 is already where it should be.
  36.     MOVE.L    A7,(A0)+        ; Save initial value of A7 at IntA7
  37.     LINK    PS,#-512        ; reserve 512 bytes for the stack
  38.     MOVE.L    RS,(A0)+        ; save return stack bottom at Rzero
  39.     MOVE.L    PS,(A0)+        ; Save under flow address at UFlow
  40.     SUBQ.L    #2,PS            ; leave room for under flow
  41.     MOVE.L    PS,(A0)            ; Put parameter stack bot. at Szero
  42.  
  43.     ; setup compile point register
  44.     MOVE    FreePt-Base(BP),D0    ; rel compile buffer pointer
  45.     LEA    0(BP,D0.W),DP        ; abs addr into DP register
  46.  
  47.     ; setup dictionary pointer register
  48.     CLR.L    Dict
  49.     MOVE    DictPt-base(BP),Dict    ; rel.addr of the last dict. entry
  50.  
  51.     ; set the dictionary size
  52.     MOVE    freesz-base(BP),-(PS)
  53.     JSR    grow-base(BP)
  54.  
  55. Warm:    MOVEA.L    Rzero-Base(BP),RS    ; reset return stack
  56.     MOVEA.L    Szero-Base(BP),PS    ; reset parameter stack
  57.     JSR    page-Base(BP)        ; clear the page
  58.     MOVE    opener-base(BP),D0
  59.     JSR    0(BP,D0)        ; run the open routine 3/30/88
  60.     CLR.L    fcolon-base(BP)
  61.     BSET.B    #7,fint-base(BP)
  62. Restart:
  63.     BSR.S    GetInput
  64. Main:    JSR    token-Base(BP)        ; get the next word
  65.     MOVE    Dict,-(PS)        ; push pointer to last name
  66.     JSR    search-Base(BP)        ; find current token in dictionary
  67.     TST    (PS)+            ; found NOT IF,
  68.     BEQ.S    TestNum            ; ... assume its a number
  69.     BCLR    #7,fimmed-base(BP)    ; ELSE, immediate? IF
  70.     BNE.S    GoDo            ; ... do it
  71.     TST.B    fcolon-base(BP)        ; ELSE, compiling? NOT IF,
  72.     BEQ.S    GoDo            ; ... do it
  73.     BCLR    #7,fmacro-base(BP)    ; ELSE, macro? IF
  74.     BNE.S    domc
  75.     JSR    Compile-base(BP)    ; ELSE, compile a JSR to it
  76.     BRA.S    Main
  77.   GoDo:    JSR    Execute-base(BP)
  78.     JSR    StkChk-base(BP)
  79.     BRA.S    Main
  80.   domc:    JSR    mcomp-base(BP)
  81.     BRA.S    Main
  82.     
  83.   TestNum:
  84.     JSR    here-base(BP)        ; get the relative address of token
  85.     JSR    Number-base(BP)        ; convert it to a value, if posible
  86.     TST    (PS)+            ;  was it?
  87.     BNE.S    @0            ; IF NOT,
  88.     JMP    WhaZat-base(BP)        ;    say huh??? and EXIT
  89.     @0:    TST.B    fcolon-base(BP)        ; THEN, are you compiling?
  90.     BEQ.S    Main            ; IF NOT, leave it on the stack
  91.     JSR    Literal-base(BP)    ; ELSE, compile it as a literal
  92.     BRA.S    Main            ; THEN, get on with it
  93.  
  94. GetInput:
  95.     TST.B    fint-base(BP)
  96.     BEQ    Pasting            ; Get a line from scrap data
  97.     TST.B    fcolon-base(BP)
  98.     BNE.S    Line
  99.     JSR    Prompt-Base(BP)
  100.     BRA.S    Line
  101.     
  102. Line:    LEA    termbuf-base(BP),IS    ; set the input stream to termbuf
  103.     MOVEQ    #76,D0
  104.     @0: MOVE.L    #$20202020,0(IS,D0.W)
  105.     SUBQ    #4,D0
  106.     BGE.S    @0
  107.     MOVE    #termbuf-base,-(PS)
  108.     MOVE    #80,-(PS)
  109.     JMP    xpect-base(BP)
  110.  
  111. DictStart:
  112.     DCB.B    6,0            ; End of dictionary search
  113.     
  114.     DC.B    129,13,0,0        ; "{cr}" ( -- ) goto restart
  115.     DC.W    dictstart-base
  116. CRet:    MOVE.L    Rzero,RS        ; reset return stack
  117.     JMP    Restart-base(BP)    ; and jump
  118.     
  119.     DC.B    129,0,0,0        ; "{null}" ( -- ) same as cret
  120.     DC.W    cret-theLink
  121. NRet:    BRA.S    cret
  122.  
  123.     DC.B    9,'?TE'            ; "?terminal" ( -- flag )
  124.     DC.W    nret-theLink        ;  was a key pressed?
  125. QTerm:    JSR    nextevent-base(BP)
  126.     CLR    -(PS)
  127.     TST    kflag-base(BP)
  128.     BEQ.S    @0
  129.     SUBQ    #1,(PS)
  130.     @0:    RTS
  131.  
  132.     DC.B    3,'KEY'            ; "key" ( -- ascii )
  133.     DC.W    qterm-theLink        ;   wait for a key press
  134. Key:    JMP    keycode-base(BP)
  135.